\ input 05.1.24 NAB
\ Provides a standard dialog for
\ text input.  Requires
\ 'Qrsrc.PRC' to be installed.

needs graphics
needs core-ext
needs Events
needs Forms
needs Fields
needs zstrings
needs resources

(ID) p4ap (ID) util use-resources

4000 constant inputFormID
4001 constant inputFieldID

2variable inputfldptr

: inputfldlen ( -- len )
  inputfldptr 2@  FldGetTextLength ;

: title ( daddr --)
  FrmGetActiveForm FrmSetTitle ;

: zstring>Field ( z-adr u fieldID -- Err )
  >r  drop >abs 
  r> GetObjectPtr FldSetTextPtr ;

: get-input
\ ( a1 u1 max a2 u2 a3 u3
\    -- false | u4 true )
\ a1 u1: input string
\ max: max chars allowed
\ a2 u2: prompt string
\ a3 u3: title string
\ u4: new length
  cursor-position 2>r
\  FrmGetActiveFormID >r
  inputFormID PopupForm
  drop >abs title
  21 7 at  type  \ prompt string
  inputFieldID FieldFocus
\ Set max. field length:
  inputFieldID GetObjectPtr
  2dup inputfldptr 2!  \ for later
  FldSetMaxChars
  2dup
  inputFieldID string>Field drop
\ Loop until a button pressed:
  begin
    ekey ctlSelectEvent = if
      drop  inputfldlen swap
      event-id if  \ OK button
        inputFieldID Field>string drop
        true
      else  2drop false  then
      0 FrmReturnToForm
      2r> at  exit
    then
  again ;
